DefInt A-Z

'Window API Function Declarations
'
Declare Function GetMenu% Lib "user" (ByVal hwnd%)
Declare Function GetSubMenu% Lib "user" (ByVal hMenu%, ByVal nPos%)
Declare Function GetMenuItemID% Lib "user" (ByVal hMenu%, ByVal nPos%)
Declare Function ModifyMenu% Lib "user" (ByVal hMenu%, ByVal nPosition%, ByVal wFlags%, ByVal wIDNewItem%, ByVal lpNewItem&)
Declare Function SetMenuItemBitmaps% Lib "user" (ByVal hMenu%, ByVal nPosition%, ByVal wFlags%, ByVal hBitmapUnchecked%, ByVal hBitmapChecked%)
Declare Function TrackPopupMenu Lib "user" (ByVal hMenu, ByVal r1, ByVal X, ByVal Y, ByVal r2, ByVal hwnd, ByVal r3&)
Declare Function GetSystemMenu Lib "user" (ByVal hwnd%, ByVal revert%) As Integer
Const MF_BITMAP = &H4

Const CLR_MENUBAR = &H80000004

Const TRUE = -1, FALSE = 0

Dim TextItems$(4), LastSelection%, CurrentText%, hMenu%

Sub Form_Load ()
  
'* Obtain handle to the Forms top level menu

  hMenu% = GetMenu(hwnd)

  Static_Bitmaps_To_Menus
   
'* Initial String with text displayed when menus are selected.
'* (Just so something happens when a menu is selected.)

   TextItems$(0) = "Writing Tools"
   TextItems$(1) = "Fonts"
   TextItems$(2) = "Books/Notes"
   TextItems$(3) = "Printers"
   TextItems$(4) = "Computers"

'* Set "Dynamic" menus submenus initial Menu text values
'* to Fontname + Fontsize of each menu item

  For I% = 0 To 4
    MSubMenu(I%).Caption = picture3(I%).FontName + Str$(picture3(I%).FontSize) + " Pnt"
  Next I%

End Sub

Sub SubMenu_Click (Index As Integer)

Static LastSelection%
   
'* Set text to that of selected menu item and
'* display the new text

  CurrentText% = Index
  Form_Paint

'* Uncheck last selected item and check seledted item

  SubMenu(LastSelection%).Checked = FALSE  'Check selected menu
  SubMenu(Index).Checked = TRUE            'UnCheck last selected menu

  LastSelection% = Index                   'Save current selection
   
End Sub

Sub MSubMenu_Click (Index As Integer)

Static LastSelection%
 
'* Reset forms FontSize to selected fontsize
'* and redisplay current text

  FontSize = picture3(Index).FontSize
  Form_Paint

'* Uncheck last selected item and check selected item

  MSubMenu(LastSelection%).Checked = FALSE
  MSubMenu(Index).Checked = TRUE
   
  LastSelection% = Index

End Sub

Sub Create_Dynamic_Menu_Bitmaps ()
  
  For I% = 0 To 4
  
  '* Set the width and height of the Picture controls
  '* based on their corresponding Menu items caption,
  '* and the Picture controls Font and FontSize.
  '* DoEvents() is neccessary to make new dimension
  '* values to take affect prior to exiting this Sub.

    picture3(I%).Width = picture3(I%).TextWidth(MSubMenu(I%).Caption)
    picture3(I%).Height = picture3(I%).TextHeight(MSubMenu(I%).Caption)
    X% = DoEvents()

  '* Set Backcolor of Picture control to that of the
  '* current system Menu Bar color, so Dynamic bitmaps
  '* will appear as normal menu items when menu bar
  '* color is changed via the control panel

    picture3(I%).BackColor = CLR_MENUBAR
    
  '* Print Text onto Picture control.  This text will
  '* become the bitmap.

    picture3(I%).Print MSubMenu(I%).Caption

  Next I%

'* Obtain handle Second submenu

  hSubMenu% = GetSubMenu(hMenu%, 1)

'* - Set picture controls backgroup picture (Bitmap) to its Image.
'*       Can't use the Image bitmap directly for some reason.
'* - Get ID of sub menu
'* - Replace menu text with bitmap from corresponding picture control
'* - Replace bitmap for menu check mark with custom check mark bitmap

  For I% = 0 To 4
    picture3(I%).Picture = picture3(I%).Image
    menuId% = GetMenuItemID(hSubMenu%, I%)
    X% = ModifyMenu(hMenu%, menuId%, MF_BITMAP, menuId%, CLng(picture3(I%).Picture))
    X% = SetMenuItemBitmaps(hMenu%, menuId%, 0, 0, CLng(picture2.Picture))
  Next I%

End Sub

Sub Form_Paint ()
  Cls
  Print TextItems$(CurrentText%)
End Sub

Sub CreateDynamic_Click ()
  CreateDynamic.enabled = FALSE
  Create_Dynamic_Menu_Bitmaps
End Sub

Sub Static_Bitmaps_To_Menus ()

'* Obtain handle to first submenu

   hSubMenu% = GetSubMenu(hMenu%, 0)

'* - Get ID of each sub menu
'* - Replace menu text with bitmap from corresponding picture control
'* - Replace bitmap for menu check mark with custom check mark bitmap

   For I% = 0 To 4
     menuId% = GetMenuItemID(hSubMenu%, I%)
     X% = ModifyMenu(hMenu%, menuId%, MF_BITMAP, menuId%, CLng(picture1(I%).Picture))
     X% = SetMenuItemBitmaps(hMenu%, menuId%, 0, 0, CLng(picture2.Picture))
   Next I%
   
   SubMenu(1).enabled = 0
   hMenu% = GetSystemMenu(hwnd, 0)
   menuId% = &HF120
   X% = ModifyMenu(hMenu%, menuId%, MF_BITMAP, menuId%, CLng(picture3(0).Picture))

End Sub

Sub Form_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)

    ScaleMode = 3
    InPixels = ScaleWidth
    ScaleMode = 1
    IX = (X + Left) \ (ScaleWidth \ InPixels)
    IY = (Y + (Top + (Height - ScaleHeight - (Width - ScaleWidth)))) \ (ScaleWidth \ InPixels)
    R = TrackPopupMenu(GetSubMenu(hMenu%, Button - 1), 0, IX, IY, 0, hwnd, 0)

End Sub